; ORIGINAL: 3dt2.1/examples/sphere.scm
; $Id: sphere.scm,v 1.4 1998/09/29 16:06:47 jmb Exp $
;- sphere.scm ------------------------------------------------------
; rubber band a sphere
; (sphere) starts the procedure.
; The center is picked.
; The radius is rubber banded.
; The sphere is dropped when the user clicks again.
; The new entity is returned.
;------------------------------------------------------------------
(require 'old-rb "old-rb.scm")

(define sphere
  (lambda ()
    (let* ((center (pick:position (read-ray)))
           (sides 20)
           ;; Define a vector to contain the vertex positions
           (points (make-vector (+ sides 1) (position 0 0 0)))
           ;; Compute the transformation from one vertex to the next
           (cur-view #f)
           (normal (gvector 0 0 1))
           (trans (transform:rotation center normal (/ 360 sides)))
           ;; Define a procedure to compute the new vertices
           (compute (lambda (pos)
             (vector-set! points 0 (position:copy pos))
             (vector-set! points sides (position:copy pos))
             (do ((i 1 (+ i 1)))
               ((= i sides))
               (vector-set! points i
                                (position:transform (vector-ref points (- i 1))
                                                    trans)
             ))))
           ;; Define a procedure to draw/undraw the rubber band circle
           (draw (lambda ()
             (if cur-view
               (begin
                 (view:set-rb-mode #t cur-view)
                 (view:draw-polyline points cur-view)
                 (view:set-rb-mode #f cur-view)
               ))))
          )
      (begin
        ;; Start rubber banding - remember view and draw circle
        (set! rb-start-hook (lambda (pe)
          (begin
            (set! cur-view (event:view pe))
            ;; Compute the transformation from one vertex to the next
            (set! normal (gvector:from-to (view:target cur-view)
                                          (view:eye cur-view)))
            (set! trans (transform:rotation center normal (/ 360 sides)))
            (compute (pick:position pe center normal))
            (draw))))
        ;; Stop rubber banding - undraw circle and forget view
        (set! rb-stop-hook (lambda ()
          (begin (draw) (set! cur-view #f))))
        ;; Mouse moved - recompute and draw circle
        (set! rb-update-hook (lambda (pe)
          (begin (draw) (compute (pick:position pe center normal)) (draw))))
        (rb:scheme #t)
        ;; Get final position
        (let ((pos (pick:position (read-ray) center normal)))
          (begin
            ;; Stop rubber banding and create sphere
            (rb:scheme #f)
            (set! rb-start-hook '())
            (set! rb-stop-hook '())
            (set! rb-update-hook '())
            (solid:sphere center (position:distance center pos))
          )
        )
      )
    )
  )
)
